home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / v3 / sim.lha / sim / main.c < prev    next >
C/C++ Source or Header  |  1992-08-12  |  44KB  |  1,419 lines
  1. /************************************************************************
  2. *                                                                       *
  3. * The SB-Prolog System                                                  *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona, 1987      *
  5. *                                                                       *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies.
  23. ------------------------------------------------------------------ */
  24. /* main.c */
  25.  
  26. #include "simdef.h"
  27. #include "aux.h"
  28. #include "inst.h"
  29.  
  30. #define NEXT_INSTRUCTION     goto contcase
  31.  
  32. #define OPREGC        (rreg[*lpcreg++])
  33. #define OPREG         ((LONG)(rreg + *lpcreg++))
  34. #define VARC(varno)   FOLLOW(lereg - (LONG)(varno))
  35. #define OPVARC        VARC(*lpcreg++)
  36. #define OPVAR         ((LONG)(lereg - (LONG)*lpcreg++))
  37.  
  38. #define PAD           lpcreg++
  39. #define OP2WORD       op2 = *(LONG_PTR)lpcreg;  lpcreg += 2
  40. #define NPARSE_VWv    op1 = OPVARC;  OP2WORD
  41. #define NPARSE_RWv    op1 = OPREGC;  OP2WORD
  42. #define NPARSE_Rv     op1 = OPREGC
  43. #define NPARSE_Vv     op1 = OPVARC
  44. #define NPARSE_PW     lpcreg++;  OP2WORD    /* note op2! */
  45. #define NPARSE_BW     op1 = *lpcreg++;  OP2WORD
  46. #define NPARSE_B      op1 = *lpcreg++
  47.  
  48. extern LONG_PTR set_intercode();
  49. extern double   floatval();
  50. extern LONG     makefloat();
  51. extern          eval();
  52.  
  53. LONG   temp_res;
  54. double result;
  55. WORD   floatp, current_opcode;
  56. LONG simpath;
  57.  
  58. main(argc, argv)
  59. int  argc;
  60. char *argv[];
  61. {
  62.    register WORD_PTR lpcreg;        /* local pcreg */
  63.    register LONG_PTR lereg;         /* local ereg */
  64.    register LONG_PTR rreg;          /* for SUN */
  65.    register LONG_PTR sreg;
  66.    register LONG_PTR top;
  67.    register LONG     op1;
  68.    LONG              op2, op3;
  69.    LONG              top1, top2;
  70.    PSC_REC_PTR       psc_ptr;
  71.    WORD              i, arity;      /* to unify subfields of op1 and op2 */
  72.    LONG_PTR          tempbreg;      /* for subtryme, rerestore, trrestore */
  73.    LONG_PTR          oldtr;
  74.    BYTE              flag;          /* read/write mode flag */
  75.  
  76.    arm_intercept();                 /* set up interrupt routine */
  77.    init_sim(argc, argv);            /* set up memory according to arguments */
  78.  
  79.    /* init_parse_routine(); */      /* set up array of pointers to functions */
  80.    init_load_routine();             /* set up array of pointers to functions */
  81.    init_builtin();                  /* set up array of pointers to functions */
  82.    init_loading(argc, argv);        /* load input files (bc_files) */
  83.    init_simpath(&simpath);        /* set up SIMPATH */
  84.  
  85.    if (disassem) {                  /* disassembly is requested */
  86.       dis();
  87.       printf("The byte code file is dumped in the file dump.pil\n");
  88.       exit(0);
  89.    }
  90.  
  91.    lpcreg = inst_begin;
  92.    lereg = ereg;
  93.    rreg   = (LONG_PTR)®[0];      /* for SUN */
  94.  
  95. /******************************************************************************/
  96. contcase:                           /* TOP OF EXECUTION LOOP */
  97.  
  98.    switch (*lpcreg++) {             /* switch on current opcode */
  99.  
  100.       case getpvar:                 /* PSS    Variable, Register */
  101.          PAD;
  102.          op1 = *lpcreg++;
  103.          VARC(op1) = OPREGC;
  104.          NEXT_INSTRUCTION;
  105.  
  106.       case getpval:                 /* PVR */
  107.          PAD;
  108.          op1 = OPVARC;
  109.          op2 = OPREGC;
  110.          goto nunify;
  111.  
  112.       case getstrv:                 /* VW */
  113.          NPARSE_VWv;
  114.          goto nunify_with_str;
  115.  
  116.       case gettval:                 /* PRR */
  117.          PAD;
  118.          op1 = OPREGC;
  119.          op2 = OPREGC;
  120.          goto nunify;
  121.  
  122.       case getcon:                  /* RW */
  123.          NPARSE_RWv;
  124.          goto nunify_with_con;
  125.  
  126.       case getnil:                  /* R */
  127.          NPARSE_Rv;
  128.          goto nunify_with_nil;
  129.  
  130.       case getstr:                  /* RW */
  131.          NPARSE_RWv;
  132.          goto nunify_with_str;
  133.  
  134.       case getlist:                 /* R */
  135.          NPARSE_Rv;
  136.          goto nunify_with_list_sym;
  137.  
  138.       case unipvar:                 /* V */
  139.          if (flag == WRITEFLAG) {
  140.             OPVARC = (LONG)hreg;
  141.             NEW_HEAP_FREE;
  142.          } else OPVARC = *sreg++;
  143.          NEXT_INSTRUCTION;
  144.  
  145.       case unipval:                 /* V */
  146.          NPARSE_Vv;
  147.          if (flag == WRITEFLAG)
  148.             goto nbldval;
  149.          else {
  150.             op2 = *sreg++;
  151.             goto nunify;
  152.          }
  153.  
  154.       case unitvar:                 /* R */
  155.          if (flag == WRITEFLAG) {
  156.             OPREGC = (LONG)hreg;
  157.             NEW_HEAP_FREE;
  158.          } else OPREGC = *sreg++;
  159.          NEXT_INSTRUCTION;
  160.  
  161.       case unitval:                 /* R */
  162.          NPARSE_Rv;
  163.          if (flag == WRITEFLAG)
  164.             goto nbldval;
  165.          else {
  166.             op2 = *sreg++;
  167.             goto nunify;
  168.          }
  169.  
  170.       case unicon:                  /* PW */
  171.          NPARSE_PW;                 /* note goes to op2! */
  172.          if (flag == WRITEFLAG) {
  173.             NEW_HEAP_CON(op2);
  174.             NEXT_INSTRUCTION;
  175.          } else {                   /* op2 already set */
  176.             op1 = *sreg++;
  177.             goto nunify_with_con;
  178.          }
  179.  
  180.       case uninil:                  /* P */
  181.          PAD;
  182.          if (flag == WRITEFLAG) {
  183.             NEW_HEAP_NODE(nil_sym);
  184.             NEXT_INSTRUCTION;
  185.          } else {
  186.             op1 = *sreg++;
  187.             goto nunify_with_nil;
  188.          }
  189.  
  190.       case getnumcon:               /* RW */
  191.          NPARSE_RWv;
  192.          goto nunify_with_int;
  193.  
  194.       case putnumcon:               /* RW */
  195.          op1 = *lpcreg++;
  196.          rreg[op1] = MAKEINT(*(LONG_PTR)lpcreg);
  197.          lpcreg += 2;
  198.          NEXT_INSTRUCTION;
  199.  
  200.       case putpvar:                 /* PVR */
  201.          PAD;
  202.          op1 = OPVAR;
  203.          FOLLOW(op1) = op1;
  204.          OPREGC = op1;
  205.          NEXT_INSTRUCTION;
  206.  
  207.       case putpval:                 /* PVR */
  208.          PAD;
  209.          op1 = *lpcreg++;
  210.          OPREGC = VARC(op1);
  211.          NEXT_INSTRUCTION;
  212.  
  213.       case puttvar:                 /* PRR */
  214.          PAD;
  215.          OPREGC = (LONG)hreg;
  216.          OPREGC = (LONG)hreg;
  217.          NEW_HEAP_FREE;
  218.          NEXT_INSTRUCTION;
  219.  
  220.       case putstrv:                 /* VW */
  221.          OPVARC = (LONG)hreg | CS_TAG;
  222.          NEW_HEAP_NODE(*(LONG_PTR)lpcreg);
  223.          lpcreg += 2;
  224.          NEXT_INSTRUCTION;
  225.  
  226.       case putcon:                  /* RW */
  227.          op1 = *lpcreg++;
  228.          rreg[op1] = *(LONG_PTR)lpcreg | CS_TAG;
  229.          lpcreg += 2;
  230.          NEXT_INSTRUCTION;
  231.  
  232.       case putnil:                  /* R */
  233.          OPREGC = nil_sym;
  234.          NEXT_INSTRUCTION;
  235.  
  236.       case putstr:                  /* RW */
  237.          OPREGC = (LONG)hreg | CS_TAG;
  238.          NEW_HEAP_NODE(*(LONG_PTR)lpcreg);
  239.          lpcreg += 2;
  240.          NEXT_INSTRUCTION;
  241.  
  242.       case putlist:                 /* R */
  243.          OPREGC = (LONG)hreg | LIST_TAG;
  244.          NEXT_INSTRUCTION;
  245.  
  246.       case bldpvar:                 /* V */
  247.          OPVARC = (LONG)hreg;
  248.          NEW_HEAP_FREE;
  249.          NEXT_INSTRUCTION;
  250.  
  251.       case bldpval:                 /* V */
  252.          NPARSE_Vv;
  253.          goto nbldval;
  254.  
  255.       case bldtvar:                 /* R */
  256.          OPREGC = (LONG)hreg;
  257.          NEW_HEAP_FREE;
  258.          NEXT_INSTRUCTION;
  259.  
  260.       case bldtval:                 /* R */
  261.          NPARSE_Rv;
  262.          goto nbldval;
  263.  
  264.       case bldcon:                  /* PW */
  265.          PAD;
  266.          NEW_HEAP_CON(*(LONG_PTR)lpcreg);
  267.          lpcreg += 2;
  268.          NEXT_INSTRUCTION;
  269.  
  270.       case bldnil:                  /* P */
  271.          PAD;
  272.          NEW_HEAP_NODE(nil_sym);
  273.          NEXT_INSTRUCTION;
  274.  
  275.       case uninumcon:               /* PL */
  276.          NPARSE_PW;                 /* num in op2 */
  277.          if (flag == WRITEFLAG) {
  278.             NEW_HEAP_INT(op2);
  279.             NEXT_INSTRUCTION;
  280.          } else {                   /* op2 set */
  281.             op1 = *sreg++;
  282.             goto nunify_with_int;
  283.          }
  284.  
  285.       case bldnumcon:               /* PL */
  286.          NPARSE_PW;                 /* num in op2 */
  287.          NEW_HEAP_INT(op2);
  288.          NEXT_INSTRUCTION;
  289.  
  290.       case getfloatcon:             /* RW */
  291.          NPARSE_RWv;
  292.          goto nunify_with_float;
  293.  
  294.       case putfloatcon:             /* RW */
  295.          op1 = *lpcreg++;
  296.          rreg[op1] = *(LONG_PTR)lpcreg;
  297.          lpcreg += 2;               /* float already tagged */
  298.          NEXT_INSTRUCTION;
  299.  
  300.       case unifloatcon:             /* PL */
  301.          NPARSE_PW;                 /* float in op2 */
  302.          if (flag == WRITEFLAG) {
  303.             NEW_HEAP_FLOAT(op2);
  304.             NEXT_INSTRUCTION;
  305.          } else {                   /* op2 set */
  306.             op1 = *sreg++;
  307.             goto nunify_with_float;
  308.          }
  309.  
  310.       case bldfloatcon:             /* PL */
  311.          NPARSE_PW;                 /* float in op2 */
  312.          NEW_HEAP_FLOAT(op2);
  313.          NEXT_INSTRUCTION;
  314.  
  315.       case test_unifiable:          /* RRR */
  316.          /* if reg1 and reg2 are unifiable, then reg3 is set to 1,
  317.           * else reg3 is set to 0.  Logically equivalent to
  318.           * not(not(reg1 = reg2)).
  319.           */
  320.          op1 = OPREGC;
  321.          op2 = OPREGC;
  322.          op3 = OPREG;
  323.          top1 = (LONG)trreg;
  324.          FOLLOW(op3) = MAKEINT(unify(op1, op2));
  325.          while ((LONG)trreg != top1) {    /* undo bindings, if any */
  326.             top = (LONG_PTR)*(++trreg);
  327.             *(LONG_PTR *)top = top;
  328.          }
  329.          NEXT_INSTRUCTION;
  330.  
  331.       case getlist_k:               /* R */
  332.          PAD;
  333.          flag = READFLAG;
  334.          NEXT_INSTRUCTION;
  335.  
  336.       case getlist_k_tvar_tvar:     /* BBB */
  337.          PAD;
  338.          OPREGC = *sreg++;
  339.          OPREGC = *sreg;
  340.          NEXT_INSTRUCTION;
  341.  
  342.       case getlist_tvar_tvar:       /* BBB */
  343.          op1 = OPREGC;
  344. glrr:    if ((top1 = TAG(op1)) == LIST) {
  345.             sreg = (LONG_PTR)(UNTAGGED(op1));
  346.             OPREGC = *sreg++;
  347.             OPREGC = *sreg;
  348.             NEXT_INSTRUCTION;
  349.          }
  350.      else if (top1 == FREE) {
  351.             NDEREF(op1, glrr);
  352.             FOLLOW(op1) = (LONG)hreg | LIST_TAG;
  353.             PUSHTRAIL(op1);
  354.             OPREGC = (LONG)hreg;
  355.             NEW_HEAP_FREE;
  356.             OPREGC = (LONG)hreg;
  357.             NEW_HEAP_FREE;
  358.             NEXT_INSTRUCTION;
  359.      }
  360.          else if (top1 == CS || top1 == NUM) {
  361.             FAIL1;
  362.             NEXT_INSTRUCTION;
  363.      }  /* end getlist_tvar_tvar */
  364.  
  365.       case getcomma:                /* R */
  366.          NPARSE_Rv;
  367.          op2 = (LONG)comma_psc;
  368.          goto nunify_with_str;
  369.  
  370.       case getcomma_tvar_tvar:      /* BBB */
  371.          op1 = OPREGC;
  372. gcrr:    switch (TAG(op1)) {
  373.             case FREE: NDEREF(op1, gcrr);
  374.                        FOLLOW(op1) = (LONG)hreg | CS_TAG;
  375.                        PUSHTRAIL(op1);
  376.                        NEW_HEAP_NODE((LONG)comma_psc);
  377.                        PUSHTRAIL(op1);
  378.                        OPREGC = (LONG)hreg;
  379.                        NEW_HEAP_FREE;
  380.                        OPREGC = (LONG)hreg;
  381.                        NEW_HEAP_FREE;
  382.                        NEXT_INSTRUCTION;
  383.             case CS  : UNTAG(op1);
  384.                        if (FOLLOW(op1) == (LONG)comma_psc) {
  385.                           sreg = (LONG_PTR)(op1+4);
  386.                           OPREGC = *sreg++;
  387.                           OPREGC = *sreg;
  388.                           NEXT_INSTRUCTION;
  389.                        }
  390.             case NUM :
  391.             case LIST: FAIL1;
  392.                        NEXT_INSTRUCTION;
  393.          }  /* end getcomma_tvar_tvar */
  394.  
  395.       case trymeelse:               /* BA */
  396.          NPARSE_BW;
  397.          goto subtryme;
  398.  
  399.       case retrymeelse:             /* BA */
  400.          op1 = *lpcreg++;
  401.          *(breg + 1) = *(LONG_PTR)lpcreg;
  402.          lpcreg += 2;
  403.          goto rerestore;
  404.  
  405.       case trustmeelsefail:         /* B */
  406.          NPARSE_B;
  407.          goto trrestore;
  408.  
  409.       case try:                     /* BA */
  410.          op1 = *lpcreg++;
  411.          op2 = (LONG)(lpcreg + 2);
  412.          lpcreg = (WORD_PTR)*(LONG_PTR)lpcreg;
  413.          goto subtryme;
  414.  
  415.       case retry:                   /* BA */
  416.          op1 = *lpcreg++;
  417.          *(breg + 1) = (LONG)(lpcreg + 2);
  418.          lpcreg = (WORD_PTR)*(LONG_PTR)lpcreg;
  419.          goto rerestore;
  420.  
  421.       case trust:                   /* BA */
  422.          op1 = *lpcreg++;
  423.          lpcreg = (WORD_PTR)*(LONG_PTR)lpcreg;
  424.          goto trrestore;
  425.  
  426.       case getpbreg:                /* V */
  427.          OPVARC = (LONG)breg | NUM_TAG;
  428.          NEXT_INSTRUCTION;
  429.  
  430.       case gettbreg:                /* R */
  431.          OPREGC = (LONG)breg | NUM_TAG;
  432.          NEXT_INSTRUCTION;
  433.  
  434.       case putpbreg:                /* V */
  435.          NPARSE_Vv;
  436.          DEREF(op1);
  437.          breg  = (LONG_PTR)UNTAGGED(op1);
  438.          hbreg = (LONG_PTR)*(breg + 3);
  439.          NEXT_INSTRUCTION;
  440.  
  441.       case puttbreg:                /* R */
  442.          NPARSE_Rv;
  443.          DEREF(op1);
  444.          breg = (LONG_PTR)UNTAGGED(op1);
  445.          hbreg = (LONG_PTR)*(breg + 3);
  446.          NEXT_INSTRUCTION;
  447.  
  448.       case switchonterm:            /* RWW */
  449.          op1 = OPREGC;
  450. sotd:    if ((top1 = TAG(op1)) == LIST) {
  451.             lpcreg += 2;
  452.             lpcreg = *(WORD_PTR *)lpcreg;
  453.             NEXT_INSTRUCTION;
  454.      }
  455.          else if (top1 == CS) {
  456.        if (GET_STR_ARITY(op1) == 0) {
  457.               lpcreg = *(WORD_PTR *)lpcreg;
  458.               NEXT_INSTRUCTION;
  459.             }
  460.        else {
  461.             lpcreg += 2;
  462.             lpcreg = *(WORD_PTR *)lpcreg;
  463.             NEXT_INSTRUCTION;
  464.        }
  465.      }
  466.      else if (top1 == FREE) {
  467.        NDEREF(op1, sotd);
  468.            lpcreg += 4;
  469.            NEXT_INSTRUCTION;
  470.      } 
  471.      else {
  472.        lpcreg = *(WORD_PTR *)lpcreg;
  473.            NEXT_INSTRUCTION;
  474.      }   /* end switchonterm */
  475.  
  476.       case arg:                     /* RRR */
  477.          op1 = OPREGC;              /* index, i */
  478.          op2 = OPREGC;              /* term being indexed into, T */
  479.          op3 = OPREGC;              /* i_th. argument of T */
  480.          DEREF(op1);
  481.          if (!ISINTEGER(op1)) {
  482.             printf("arg: Index must be an integer.\n");
  483.             FAIL1;
  484.             NEXT_INSTRUCTION;
  485.          }
  486.          op1 = INTVAL(op1);
  487.          if (op1 <= 0) {
  488.             printf("arg: index must be > 0\n");
  489.             FAIL1;
  490.             NEXT_INSTRUCTION;
  491.          }
  492.          DEREF(op2);
  493.          if (ISCONSTR(op2) && op1 <= GET_STR_ARITY(op2))
  494.             if (unify(*((LONG_PTR)UNTAG(op2) + op1), op3))
  495.                NEXT_INSTRUCTION;
  496.          if (ISLIST(op2) && op1 <= 2)
  497.             if (unify(*((LONG_PTR)UNTAG(op2) + op1 - 1), op3))
  498.                NEXT_INSTRUCTION;
  499.          FAIL1;
  500.          NEXT_INSTRUCTION;
  501.  
  502.       case arg0:                    /* RRR */
  503.          op1 = OPREGC;              /* index, i */
  504.          op2 = OPREGC;              /* term being indexed into, T */
  505.          op3 = OPREGC;              /* i_th. argument of T */
  506.          DEREF(op1);
  507.          if (!ISINTEGER(op1)) {
  508.             printf("arg: Index must be an integer.\n");
  509.             FAIL1;
  510.             NEXT_INSTRUCTION;
  511.          }
  512.          op1 = INTVAL(op1);
  513.          if (op1 <= 0) {
  514.             printf("arg: index must be > 0\n");
  515.             FAIL1;
  516.             NEXT_INSTRUCTION;
  517.          }
  518.          DEREF(op2);
  519.          if (ISCONSTR(op2) && op1 <= GET_STR_ARITY(op2))
  520.             op2 = *((LONG_PTR)UNTAG(op2) + op1);
  521.          else if (ISLIST(op2) && op1 <= 2)
  522.             op2 = *((LONG_PTR)UNTAG(op2) + op1 - 1);
  523.          else {
  524.             FAIL1;
  525.             NEXT_INSTRUCTION;
  526.          }
  527.          DEREF(op3);
  528.          if (ISNONVAR(op2)) {
  529.             FOLLOW(op3) = op2;
  530.             PUSHTRAIL(op3);
  531.          } else {                          /* op2 is a variable */
  532.             if (op2 != op3) {
  533.                if (op2 < op3) {
  534.                   if (op2 < (LONG)hreg) {  /* op2 not in loc stack */
  535.                      FOLLOW(op3) = op2;
  536.                      PUSHTRAIL(op3);
  537.                   } else {                 /* op2 points to op3 */
  538.                      FOLLOW(op2) = op3;
  539.                      PUSHTRAIL(op2);
  540.                   }
  541.                } else {                    /* op2 > op3 */
  542.                   if (op3 < (LONG)hreg) {
  543.                      FOLLOW(op2) = op3;
  544.                      PUSHTRAIL(op2);
  545.                   } else {
  546.                      FOLLOW(op3) = op2;
  547.                      PUSHTRAIL(op3);
  548.                   }
  549.                }
  550.             }
  551.          }
  552.          NEXT_INSTRUCTION;
  553.  
  554.       case switchonbound:           /* RWW */
  555.          op1 = OPREGC;
  556. sotd1:   switch (TAG(op1)) {
  557.             case FREE: NDEREF(op1, sotd1);
  558.                        lpcreg += 4;
  559.                        NEXT_INSTRUCTION;
  560.             case NUM : op1 = NUMVAL(op1);
  561.                        break;
  562.             case LIST: op1 = *(LONG_PTR)UNTAGGED(list_str);
  563.                        break;
  564.             case CS  : op1 = (LONG)GET_STR_PSC(op1);
  565.                        break;
  566.          }
  567.          op2 = *(LONG_PTR)lpcreg;
  568.          lpcreg += 2;
  569.          op3 = *(LONG_PTR)lpcreg;
  570.          lpcreg = *(WORD_PTR *)(IHASH(op1, op3) * 4 + op2);
  571.          NEXT_INSTRUCTION;
  572.  
  573.       case switchonlist:            /* RWW */
  574.          /* this is a specialization of the switchonterm instruction:
  575.           * switchonlist R, L1, L2 means: if reg R DEREFs to '[]', goto
  576.           * L1; if it DEREFs to [_|_], goto L2; if it DEREFs to a variable,
  577.           * fall through; else fail.
  578.           */
  579.          op1 = OPREGC;
  580. sold:    switch (TAG(op1)) {
  581.             case FREE: NDEREF(op1, sold);
  582.                        lpcreg += 4;
  583.                        NEXT_INSTRUCTION;
  584.             case NUM : FAIL1;
  585.                        NEXT_INSTRUCTION;
  586.             case CS  : if (op1 == nil_sym)
  587.                           lpcreg = *(WORD_PTR *)lpcreg;
  588.                        else
  589.                           FAIL1;
  590.                        NEXT_INSTRUCTION;
  591.             case LIST: sreg = (LONG_PTR)(UNTAGGED(op1));
  592.                        lpcreg += 2;
  593.                        lpcreg = *(WORD_PTR *)lpcreg;
  594.                        NEXT_INSTRUCTION;
  595.          }  /* end switchonlist */
  596.  
  597.       case get_tag:                 /* PRR */
  598.          /* DEREFs 1st operand reg, copies low 3 bits into 2nd operand reg */
  599.          PAD;
  600.          op1 = OPREGC;  DEREF(op1);
  601.          OPREGC = MAKEINT(op1 & 0x7);
  602.          NEXT_INSTRUCTION;
  603.  
  604.       case movreg:                  /* PRR */
  605.          PAD;
  606.          op1 = *lpcreg++;
  607.          OPREGC = rreg[op1];
  608.          NEXT_INSTRUCTION;
  609.  
  610.       case negate:
  611.          op1 = *lpcreg++;
  612.          op2 = rreg[op1];  DEREF(op2);
  613.          if (!ISINTEGER(op2)) {
  614.             printf("negate: integer required\n");
  615.             FAIL1;
  616.          } else rreg[op1] = MAKEINT(~INTVAL(op2));
  617.          NEXT_INSTRUCTION;
  618.  
  619.       case and:
  620.          PAD;
  621.          op1 = OPREGC;
  622.          op3 = OPREG;
  623.          op2 = FOLLOW(op3);
  624.          DEREF(op1);
  625.          DEREF(op2);
  626.          if (!ISINTEGER(op1) || !ISINTEGER(op2)) {
  627.             printf("and: integer required\n");
  628.             FAIL1;
  629.          } else FOLLOW(op3) = MAKEINT(INTVAL(op2) & INTVAL(op1));
  630.          NEXT_INSTRUCTION;
  631.  
  632.       case or:
  633.          PAD;
  634.          op1 = OPREGC;
  635.          op3 = OPREG;
  636.          op2 = FOLLOW(op3);
  637.          DEREF(op1);
  638.          DEREF(op2);
  639.          if (!ISINTEGER(op1) || !ISINTEGER(op2)) {
  640.             printf("or: integer required\n");
  641.             FAIL1;
  642.          } else FOLLOW(op3) = MAKEINT(INTVAL(op2) | INTVAL(op1));
  643.          NEXT_INSTRUCTION;
  644.  
  645.       case lshiftl:
  646.          PAD;
  647.          op1 = OPREGC;
  648.          op3 = OPREG;
  649.          op2 = FOLLOW(op3);
  650.          DEREF(op1);
  651.          DEREF(op2);
  652.          if (!ISINTEGER(op1) || !ISINTEGER(op2)) {
  653.             printf("lshiftl: integer required\n");
  654.             FAIL1;
  655.          } else FOLLOW(op3) = MAKEINT(INTVAL(op2) << INTVAL(op1));
  656.          NEXT_INSTRUCTION;
  657.  
  658.       case lshiftr:
  659.          PAD;
  660.          op1 = OPREGC;
  661.          op3 = OPREG;
  662.          op2 = FOLLOW(op3);
  663.          DEREF(op1);
  664.          DEREF(op2);
  665.          if (!ISINTEGER(op1) ||!ISINTEGER(op2)) {
  666.             printf("lshiftr: integer required\n");
  667.             FAIL1;
  668.          } else FOLLOW(op3) = MAKEINT(INTVAL(op2) >> INTVAL(op1));
  669.          NEXT_INSTRUCTION;
  670.  
  671.       case addreg:                /* PRR */
  672.          PAD;
  673.          op1 = OPREGC;
  674.          op3 = OPREG;
  675.          op2 = FOLLOW(op3);
  676.          DEREF(op1);
  677.          if (ISINTEGER(op1))
  678.             floatp = 0;
  679.          else if (ISFLOAT(op1))
  680.             floatp = 1;
  681.          else {
  682.             floatp = eval(op1, &top1);
  683.             op1 = top1;
  684.          }
  685.          DEREF(op2);
  686.          if (ISINTEGER(op2))
  687.             ;
  688.          else if (ISFLOAT(op2))
  689.             floatp = floatp | 1;
  690.          else {
  691.             floatp = floatp | eval(op2, &top2);
  692.             op2 = top2;
  693.          }
  694.          switch (floatp) {
  695.             case -1: printf("add: number required\n");
  696.                      FAIL1;
  697.                      NEXT_INSTRUCTION;
  698.             case  0: FOLLOW(op3) = MAKEINT(INTVAL(op2) + INTVAL(op1));
  699.                      NEXT_INSTRUCTION;
  700.             case  1: FOLLOW(op3) = makefloat(NUMVAL(op2) + NUMVAL(op1));
  701.                      NEXT_INSTRUCTION;
  702.          }
  703.          NEXT_INSTRUCTION;
  704.  
  705.       case subreg:                /* PRR */
  706.          PAD;
  707.          op1 = OPREGC;
  708.          op3 = OPREG;
  709.          op2 = FOLLOW(op3);
  710.          DEREF(op1);
  711.          if (ISINTEGER(op1))
  712.             floatp = 0;
  713.          else if (ISFLOAT(op1))
  714.             floatp = 1;
  715.          else {
  716.             floatp = eval(op1, &top1);
  717.             op1 = top1;
  718.          }
  719.          DEREF(op2);
  720.          if (ISINTEGER(op2))
  721.             ;
  722.          else if (ISFLOAT(op2))
  723.             floatp = floatp | 1;
  724.          else {
  725.             floatp = floatp | eval(op2, &top2);
  726.             op2 = top2;
  727.          }
  728.          switch (floatp) {
  729.             case -1: printf("sub: number required\n");
  730.                      FAIL1;
  731.                      NEXT_INSTRUCTION;
  732.             case  0: FOLLOW(op3) = MAKEINT(INTVAL(op2) - INTVAL(op1));
  733.                      NEXT_INSTRUCTION;
  734.             case  1: FOLLOW(op3) = makefloat(NUMVAL(op2) - NUMVAL(op1));
  735.                      NEXT_INSTRUCTION;
  736.          }
  737.          NEXT_INSTRUCTION;
  738.  
  739.       case mulreg:                /* PRR */
  740.          PAD;
  741.          op1 = OPREGC;
  742.          op3 = OPREG;
  743.          op2 = FOLLOW(op3);
  744.          DEREF(op1);
  745.          if (ISINTEGER(op1))
  746.             floatp = 0;
  747.          else if (ISFLOAT(op1))
  748.             floatp = 1;
  749.          else {
  750.             floatp = eval(op1, &top1);
  751.             op1 = top1;
  752.          }
  753.          DEREF(op2);
  754.          if (ISINTEGER(op2))
  755.             ;
  756.          else if (ISFLOAT(op2))
  757.             floatp = floatp | 1;
  758.          else {
  759.             floatp = floatp | eval(op2, &top2);
  760.             op2 = top2;
  761.          }
  762.          switch (floatp) {
  763.             case -1: printf("mul: number required\n");
  764.                      FAIL1;
  765.                      NEXT_INSTRUCTION;
  766.             case  0:  FOLLOW(op3) = MAKEINT(INTVAL(op2) * INTVAL(op1));
  767.                      NEXT_INSTRUCTION;
  768.             case  1: FOLLOW(op3) = makefloat(NUMVAL(op2) * NUMVAL(op1));
  769.                      NEXT_INSTRUCTION;
  770.          }
  771.          NEXT_INSTRUCTION;
  772.  
  773.       case divreg:                /* PRR */
  774.          PAD;
  775.          op1 = OPREGC;
  776.          op3 = OPREG;
  777.          op2 = FOLLOW(op3);
  778.          DEREF(op1);
  779.          if (!ISNUM(op1)) {
  780.             eval(op1, &top1);
  781.             op1 = top1;
  782.          }
  783.          DEREF(op2);
  784.          if (!ISNUM(op2)) {
  785.             eval(op2, &top2);
  786.             op2 = top2;
  787.          }
  788.          result = NUMVAL(op2) / NUMVAL(op1);
  789.          FOLLOW(op3) = makefloat(result);
  790.          NEXT_INSTRUCTION;
  791.  
  792.       case idivreg:               /* PRR */
  793.          PAD;
  794.          op1 = OPREGC;
  795.          op3 = OPREG;
  796.          op2 = FOLLOW(op3);
  797.          DEREF(op1);
  798.          if (ISINTEGER(op1))
  799.             floatp = 0;
  800.          else {
  801.             floatp = eval(op1, &top1);
  802.             op1 = top1;
  803.          }
  804.          DEREF(op2);
  805.          if (ISINTEGER(op2))
  806.             ;
  807.          else {
  808.             floatp = floatp | eval(op2, &top2);
  809.             op2 = top2;
  810.          }
  811.          if (floatp != 0) {
  812.             printf("integer division: operands must be integers\n");
  813.             FAIL1;
  814.          } else FOLLOW(op3) = MAKEINT(INTVAL(op2) / INTVAL(op1));
  815.          NEXT_INSTRUCTION;
  816.  
  817.       case putdval:               /* PVR */
  818.          PAD;
  819.          op1 = OPVARC;  DEREF(op1);
  820.          OPREGC = op1;
  821.          NEXT_INSTRUCTION;
  822.  
  823.       case putuval:               /* PVR */
  824.          PAD;
  825.          op1 = OPVARC;  DEREF(op1);
  826.          if (ISNONVAR(op1) || op1 < (LONG)hreg || op1 >= (LONG)lereg)
  827.             OPREGC = op1;
  828.          else {
  829.             FOLLOW(op1) = OPREGC = (LONG)hreg;
  830.             PUSHTRAIL(op1);
  831.             NEW_HEAP_FREE;
  832.          }
  833.          NEXT_INSTRUCTION;
  834.  
  835.       case call:                  /* PW */
  836.          NPARSE_PW;
  837.          cpreg = (LONG_PTR)lpcreg;
  838.          psc_ptr = (PSC_REC_PTR)op2;
  839.          goto call_sub;
  840.  
  841.       case allocate:
  842.          op1 = *lpcreg++;
  843.          op2 = (breg < lereg) ? (LONG)breg : (LONG)(lereg - ENV_SIZE(cpreg));
  844.  
  845.      /* check for heap overflow */
  846.          if ((LONG_PTR)op2 - op1 < hreg) {
  847.             ereg = lereg;
  848.             /* garbage_collection("allocate"); */ /* GC buggy! */
  849.         if ((LONG_PTR)op2 - op1 < hreg) {    /* still too full */
  850.            quit("Heap overflow\n");
  851. /*
  852.            if (!overflow_f) {
  853.                   overflow_f = 1;
  854.                   lpcreg = (WORD_PTR)set_intercode(2);
  855.                }
  856. */
  857.         }
  858.      }
  859.  
  860.          FOLLOW(op2) = (LONG)lereg;
  861.          FOLLOW(op2 - 4) = (LONG)cpreg;
  862.      lereg = (LONG_PTR)op2;
  863.          for (op2 -= 8, op1 -= 2; op1 > 0; op2 -= 4, op1 -= 1)
  864.             FOLLOW(op2) = op2;        /* init permanent vars */
  865.          NEXT_INSTRUCTION;
  866.  
  867.       case deallocate:
  868.          PAD;
  869.          cpreg  = (LONG_PTR)*(lereg - 1);
  870.          lereg = (LONG_PTR)*lereg;
  871.          NEXT_INSTRUCTION;
  872.  
  873.       case proceed:
  874.          PAD;
  875.          lpcreg = (WORD_PTR)cpreg;
  876.          NEXT_INSTRUCTION;
  877.  
  878.       case execute:
  879.          NPARSE_PW;
  880.          psc_ptr = (PSC_REC_PTR)op2;
  881.          goto call_sub;
  882.  
  883.       case calld:
  884.          PAD;
  885.          cpreg  = (LONG_PTR)(lpcreg + 2);
  886.          lpcreg = (WORD_PTR)*(LONG_PTR)lpcreg;
  887.  
  888.      /* check for potential heap overflow */
  889.          if (lereg < hreg + 100) {
  890.             ereg = lereg;
  891.             /* garbage_collection("calld"); */ /* GC buggy! */
  892.         if (lereg < hreg + 100)     /* still too full */
  893.            quit("Heap overflow\n");
  894.          }
  895.  
  896.          NEXT_INSTRUCTION;
  897.  
  898.       case jump:
  899.          PAD;
  900.          lpcreg = (WORD_PTR)*(LONG_PTR)lpcreg;
  901.          NEXT_INSTRUCTION;
  902.  
  903.       case jumpz:
  904.          op3 = OPREGC;
  905.          if (NUMVAL(op3) == 0)
  906.             lpcreg = *(WORD_PTR *)lpcreg;
  907.          else
  908.             lpcreg += 2;
  909.          NEXT_INSTRUCTION;
  910.  
  911.       case jumpnz:
  912.          op3 = OPREGC;
  913.          if (NUMVAL(op3) != 0)
  914.             lpcreg = *(WORD_PTR *)lpcreg;
  915.          else
  916.             lpcreg += 2;
  917.          NEXT_INSTRUCTION;
  918.  
  919.       case jumplt:
  920.          op3 = OPREGC;
  921.          if (NUMVAL(op3) < 0)
  922.             lpcreg = *(WORD_PTR *)lpcreg;
  923.          else
  924.             lpcreg += 2;
  925.          NEXT_INSTRUCTION;
  926.  
  927.       case jumple:
  928.          op3 = OPREGC;
  929.          if (NUMVAL(op3) <= 0)
  930.             lpcreg = *(WORD_PTR *)lpcreg;
  931.          else
  932.             lpcreg += 2;
  933.          NEXT_INSTRUCTION;
  934.  
  935.       case jumpgt:
  936.          op3 = OPREGC;
  937.          if (NUMVAL(op3) > 0)
  938.             lpcreg = *(WORD_PTR *)lpcreg;
  939.          else
  940.             lpcreg += 2;
  941.          NEXT_INSTRUCTION;
  942.  
  943.       case jumpge:
  944.          op3 = OPREGC;
  945.          if (NUMVAL(op3) >= 0)
  946.             lpcreg = *(WORD_PTR *)lpcreg;
  947.          else
  948.             lpcreg += 2;
  949.          NEXT_INSTRUCTION;
  950.  
  951.       case fail:
  952.          PAD;
  953.          FAIL1;
  954.          NEXT_INSTRUCTION;
  955.  
  956.       case noop:
  957.          NPARSE_B;
  958.          lpcreg += op1;
  959.          NEXT_INSTRUCTION;
  960.  
  961.       case halt:
  962.          PAD;
  963.          printf("\nHalt. Program terminated normally\n");
  964.          exit(0);
  965.          NEXT_INSTRUCTION;
  966.  
  967.       case builtin:
  968.          NPARSE_B;
  969.          pcreg = lpcreg;
  970.          ereg  = lereg;
  971.          Builtin(op1);
  972.          lpcreg = pcreg;
  973.          NEXT_INSTRUCTION;
  974.  
  975.       case endfile:
  976.          NPARSE_PW;
  977.          NEXT_INSTRUCTION;
  978.  
  979.       case getival:               /* RW */
  980.          NPARSE_RWv;
  981.          goto nunify;
  982.  
  983.       case jumptbreg:             /* RW */
  984.          OPREGC = (LONG)breg | NUM_TAG;
  985.          lpcreg = *(WORD_PTR *)lpcreg;
  986.          NEXT_INSTRUCTION;
  987.  
  988.       case unexec:
  989.          /* PWW, builds str on heap, and executes 2nd arg
  990.           * simulates exec(op2(op1(A1,A2,..,An)) for intercepting calls
  991.           */
  992.          NPARSE_PW;
  993.          op3 = (LONG)hreg;        /* save addr of new structure rec */
  994.          NEW_HEAP_NODE(op2);      /* set str psc ptr */
  995.          for (i = 1; i <= GET_ARITY((PSC_REC_PTR)op2); i++) {
  996.             op1 = rreg[i];
  997. unebld:     if (ISVAR(op1)) {
  998.                NDEREF(op1, unebld);
  999.                FOLLOW(op1) = (LONG)hreg;
  1000.                PUSHTRAIL(op1);
  1001.                NEW_HEAP_FREE;
  1002.             } else NEW_HEAP_NODE(op1);
  1003.          }
  1004.          rreg[1] = op3 | CS_TAG;  /* ptr to new structure on heap */
  1005.          OP2WORD;
  1006.          psc_ptr = (PSC_REC_PTR)op2;
  1007.          goto call_sub;
  1008.  
  1009.       case unexeci:
  1010.          /* PWW, builds str on heap with last arg a var,
  1011.           * and executes 2nd arg; for interpreting;
  1012.           * simulates exec(op2(op1(A1,A2,..,An-1,B),B)
  1013.           */
  1014.          NPARSE_PW;
  1015.          op3 = (LONG)hreg;        /* save addr of new structure rec */
  1016.          NEW_HEAP_NODE(op2);      /* set str psc ptr */
  1017.          for (i = 1; i < GET_ARITY((PSC_REC_PTR)op2); i++) {
  1018.             op1 = rreg[i];
  1019. unibld:     if (ISVAR(op1)) {
  1020.                NDEREF(op1, unibld);
  1021.                FOLLOW(op1) = (LONG)hreg;
  1022.                PUSHTRAIL(op1);
  1023.                NEW_HEAP_FREE;
  1024.             } else NEW_HEAP_NODE(op1);
  1025.          }
  1026.          rreg[1] = op3 | CS_TAG;  /* ptr to new structure on heap */
  1027.          rreg[2] = (LONG)hreg;
  1028.          NEW_HEAP_FREE;           /* add last field to rec */
  1029.          OP2WORD;
  1030.          psc_ptr = (PSC_REC_PTR)op2;
  1031.          goto call_sub;
  1032.  
  1033.       case executev:
  1034.          NPARSE_PW;
  1035. exun:    switch (TAG(op2)) {
  1036.             case FREE: NDEREF(op2,exun);
  1037.             case NUM : printf("Error: Illegal call\n");
  1038.                        FAIL1;
  1039.                        NEXT_INSTRUCTION;
  1040.             case CS  : psc_ptr = GET_STR_PSC(op2);
  1041.                        goto call_sub;
  1042.             case LIST: psc_ptr = list_psc;
  1043.                        goto call_sub;
  1044.          }
  1045.  
  1046.       default:
  1047.          printf("\nIllegal opcode hex %x at %x\n", *--lpcreg, lpcreg);
  1048.          exit(1);
  1049.  
  1050.    }  /* end switch */
  1051.  
  1052. /******************************************************************************/
  1053.  
  1054. /*------------------------------------------------------------------*/
  1055. nunify:                                     /* op1 and op2 are unknown type */
  1056.  
  1057.    switch (TAG(op1)) {
  1058.       case FREE:                            /* op1 is derefed free node */
  1059.          NDEREF(op1, nunify);
  1060. nunify1: switch (TAG(op2)) {
  1061.             case FREE:                      /* op1 is free, op2 is free */
  1062.                NDEREF(op2, nunify1);
  1063.                if (op1 != op2) {
  1064.                   if (op1 < op2) {
  1065.                      if (op1 < (LONG)hreg) {  /* op1 not in loc stack */
  1066.                         FOLLOW(op2) = op1;
  1067.                         PUSHTRAIL(op2);
  1068.                      } else {                 /* op1 points to op2 */
  1069.                         FOLLOW(op1) = op2;
  1070.                         PUSHTRAIL(op1);
  1071.                      }
  1072.                   } else {                    /* op1 > op2 */
  1073.                      if (op2 < (LONG)hreg) {
  1074.                         FOLLOW(op1) = op2;
  1075.                         PUSHTRAIL(op1);
  1076.                      } else {
  1077.                         FOLLOW(op2) = op1;
  1078.                         PUSHTRAIL(op2);
  1079.                      }
  1080.                   }
  1081.                }
  1082.                NEXT_INSTRUCTION;
  1083.             case CS  :                      /* op1 is free, op2 is con/str */
  1084.             case LIST:                      /* op1 is free, op2 is list    */
  1085.             case NUM :                      /* op1 is free, op2 is num     */
  1086.            FOLLOW(op1) = op2;
  1087.                PUSHTRAIL(op1);
  1088.                NEXT_INSTRUCTION;
  1089.          }  /* op1 = FREE - switch on op2 */
  1090.  
  1091.       case CS:                              /* op1 is con/str */
  1092. nunify2: switch (TAG(op2)) {
  1093.             case FREE:                      /* op1 is con/str, op2 is free */
  1094.            NDEREF(op2, nunify2);
  1095.                FOLLOW(op2) = op1;
  1096.                PUSHTRAIL(op2);
  1097.                NEXT_INSTRUCTION;
  1098.             case CS:                        /* op1 is con/str, op2 is con/str */
  1099.            if (op1 != op2) {
  1100.                   UNTAG(op1);
  1101.                   UNTAG(op2);
  1102.                   if (FOLLOW(op1) != FOLLOW(op2))
  1103.                      FAIL1;
  1104.                   else {
  1105.                      arity = GET_STR_ARITY(op1);
  1106.                      for (i = 1; i <= arity; i++)
  1107.                         if (!unify(*((LONG_PTR)op1+i), *((LONG_PTR)op2+i))) {
  1108.                            FAIL1;
  1109.                            NEXT_INSTRUCTION;
  1110.                         }
  1111.                   }
  1112.                }
  1113.                NEXT_INSTRUCTION;            /* OK by default */
  1114.             case LIST:                      /* op1 is con/str, op2 is list */
  1115.             case NUM :                      /* op1 is con/str, op2 is num  */
  1116.            FAIL1;
  1117.                NEXT_INSTRUCTION;
  1118.          }  /* op1 = CS - switch on op2 */
  1119.  
  1120.       case LIST:                            /* op1 is list */
  1121. nunify3: switch (TAG(op2)) {
  1122.             case FREE:                      /* op1 is list, op2 is free */
  1123.            NDEREF(op2, nunify3);
  1124.                FOLLOW(op2) = op1;
  1125.                PUSHTRAIL(op2);
  1126.                NEXT_INSTRUCTION;
  1127.             case CS :                       /* op1 is list, op2 is con/str */
  1128.             case NUM:                       /* op1 is list, op2 is num     */
  1129.            FAIL1;
  1130.                NEXT_INSTRUCTION;
  1131.             case LIST:                      /* op1 is list, op2 is list */
  1132.            if (op1 != op2) {
  1133.                   UNTAG(op1);
  1134.                   UNTAG(op2);
  1135.                   if (!unify(*(LONG_PTR)op1, *(LONG_PTR)op2) ||
  1136.                       !unify(*((LONG_PTR)op1 + 1), *((LONG_PTR)op2 + 1)))
  1137.                      FAIL1;
  1138.                }
  1139.                NEXT_INSTRUCTION;            /* OK by default */
  1140.          }  /* op1 = LIST - switch on op2 */
  1141.  
  1142.       case NUM:                             /* op1 is num */
  1143. nunify4: switch (TAG(op2)) {
  1144.             case FREE:                      /* op1 is num, op2 is free */
  1145.                NDEREF(op2, nunify4);
  1146.                FOLLOW(op2) = op1;
  1147.                PUSHTRAIL(op2);
  1148.                NEXT_INSTRUCTION;
  1149.             case NUM:                       /* op1 is num, op2 is num */
  1150.            if (op1 == op2)
  1151.                   NEXT_INSTRUCTION;
  1152.                else if ((ISFLOAT(op1) || ISFLOAT(op2)) &&
  1153.                      NUMVAL(op2) == NUMVAL(op1))
  1154.                   NEXT_INSTRUCTION;    /* fails by default */
  1155.             case CS  :                      /* op1 is num, op2 is con/str */
  1156.             case LIST:                      /* op1 is num, op2 is list    */
  1157.            FAIL1;
  1158.                NEXT_INSTRUCTION;
  1159.          }  /* op1 = NUM - switch on op2 */
  1160.  
  1161.    }  /* end of nunify */
  1162.  
  1163. /*------------------------------------------------------------------*/
  1164. nunify_with_con:                            /* op1 is unknown,           */
  1165.                         /* op2 is con/str (UNTAGGED) */
  1166.    switch (TAG(op1)) {
  1167.       case FREE:                            /* op1 is free, op2 is con/str */
  1168.      NDEREF(op1, nunify_with_con);
  1169.          FOLLOW(op1) = op2 | CS_TAG;
  1170.          PUSHTRAIL(op1);
  1171.          NEXT_INSTRUCTION;
  1172.       case CS:                              /* op1 is con/str, op2 is con/str */
  1173.          UNTAG(op1);
  1174.          if (op1 != op2)
  1175.             if (FOLLOW(op2) != FOLLOW(op1))
  1176.                FAIL1;
  1177.          NEXT_INSTRUCTION;                  /* OK by default */
  1178.       case LIST:                            /* op1 is list, op2 is con/str */
  1179.       case NUM :                            /* op1 is num, op2 is con/str  */
  1180.          FAIL1;
  1181.          NEXT_INSTRUCTION;
  1182.    }  /* end nunify_with_con */
  1183.  
  1184. /*------------------------------------------------------------------*/
  1185. nunify_with_int:                            /* op1 is unknown,           */
  1186.                         /* op2 is integer (UNTAGGED) */
  1187.    switch (TAG(op1)) {
  1188.       case FREE:
  1189.      NDEREF(op1, nunify_with_int);
  1190.          FOLLOW(op1) = MAKEINT(op2);
  1191.          PUSHTRAIL(op1);
  1192.          NEXT_INSTRUCTION;
  1193.       case NUM:
  1194.      if (ISINTEGER(op1) && INTVAL(op1) == op2)
  1195.             NEXT_INSTRUCTION;
  1196.          else if (ISFLOAT(op1) && floatval(op1) == op2)
  1197.             NEXT_INSTRUCTION;
  1198.          /* fails by default */
  1199.       case CS  :
  1200.       case LIST:
  1201.          FAIL1;
  1202.          NEXT_INSTRUCTION;
  1203.    }  /* end nunify_with_int */
  1204.  
  1205. /*------------------------------------------------------------------*/
  1206. nunify_with_float:                      /* op1 is unknown,                   */
  1207.                                         /* op2 is tagged float in WAM format */
  1208.    switch (TAG(op1)) {
  1209.       case FREE:
  1210.          NDEREF(op1, nunify_with_float);
  1211.          FOLLOW(op1) = op2;
  1212.          PUSHTRAIL(op1);
  1213.          NEXT_INSTRUCTION;
  1214.       case NUM:
  1215.          if (NUMVAL(op1) == floatval(op2))
  1216.             NEXT_INSTRUCTION;
  1217.          /* fails by default */
  1218.       case CS  :
  1219.       case LIST:
  1220.          FAIL1;
  1221.          NEXT_INSTRUCTION;
  1222.    }  /* end nunify_with_float */
  1223.  
  1224. /*------------------------------------------------------------------*/
  1225. nunify_with_nil:                         /* op1 is unknown,         */
  1226.                                          /* op2 is nil_sym (TAGGED) */
  1227.    switch (TAG(op1)) {
  1228.       case FREE:
  1229.      NDEREF(op1, nunify_with_nil);
  1230.          FOLLOW(op1) = nil_sym;
  1231.          PUSHTRAIL(op1);
  1232.          NEXT_INSTRUCTION;
  1233.       case CS:
  1234.      if (op1 == nil_sym)
  1235.             NEXT_INSTRUCTION;
  1236.          /* fails by default */
  1237.       case LIST:
  1238.       case NUM :
  1239.      FAIL1;
  1240.          NEXT_INSTRUCTION;
  1241.    }  /* end nunify_with_nil */
  1242.  
  1243. /*------------------------------------------------------------------*/
  1244. nunify_with_str:                         /* op1 is unknown, */
  1245.                                          /* op2 is psc_ptr  */
  1246.    switch (TAG(op1)) {
  1247.       case FREE:
  1248.      NDEREF(op1, nunify_with_str);
  1249.          FOLLOW(op1) = (LONG)hreg | CS_TAG;
  1250.          PUSHTRAIL(op1);
  1251.          NEW_HEAP_NODE(op2);
  1252.          flag = WRITEFLAG;
  1253.          NEXT_INSTRUCTION;
  1254.       case CS:
  1255.      UNTAG(op1);
  1256.          if (FOLLOW(op1) == op2) {
  1257.             flag = READFLAG;
  1258.             sreg = (LONG_PTR)op1 + 1;
  1259.             NEXT_INSTRUCTION;
  1260.          }
  1261.          /* fails by default */
  1262.       case LIST:
  1263.       case NUM :
  1264.      FAIL1;
  1265.          NEXT_INSTRUCTION;
  1266.    }  /* end nunify_with_str */
  1267.  
  1268. /*------------------------------------------------------------------*/
  1269. nunify_with_list_sym:                    /* op1 is unknown, */
  1270.                                          /* op2 is list     */
  1271.    switch (TAG(op1)) {
  1272.       case FREE:
  1273.      NDEREF(op1, nunify_with_list_sym);
  1274.          FOLLOW(op1) = (LONG)hreg | LIST_TAG;
  1275.          PUSHTRAIL(op1);
  1276.          flag = WRITEFLAG;
  1277.          NEXT_INSTRUCTION;
  1278.       case CS :
  1279.       case NUM:
  1280.      FAIL1;
  1281.          NEXT_INSTRUCTION;
  1282.       case LIST:
  1283.      sreg = (LONG_PTR)UNTAGGED(op1);
  1284.          flag = READFLAG;
  1285.          NEXT_INSTRUCTION;
  1286.    }  /* end nunify_with_list_sym */
  1287.  
  1288. /*------------------------------------------------------------------*/
  1289. nbldval:
  1290.  
  1291.    if (ISVAR(op1)) {
  1292.       NDEREF(op1, nbldval);
  1293.       FOLLOW(op1) = (LONG)hreg;
  1294.       PUSHTRAIL(op1);
  1295.       NEW_HEAP_FREE;
  1296.    } else NEW_HEAP_NODE(op1);
  1297.    NEXT_INSTRUCTION;    /* end of nbldval */
  1298.  
  1299. /*------------------------------------------------------------------*/
  1300. subtryme:
  1301.  
  1302.    tempbreg = (breg < lereg) ? breg : lereg - ENV_SIZE(cpreg);
  1303.  
  1304.    /* check for heap overflow */
  1305.    if (tempbreg - op1 - 6 < hreg) {
  1306.       ereg = lereg;
  1307.       /* garbage_collection("subtryme"); */ /* GC buggy! */
  1308.       if (tempbreg - op1 - 6 < hreg) {   /* still too full */
  1309.      quit("Heap overflow\n");
  1310. /*
  1311.      if (!overflow_f) {
  1312.             overflow_f = 1;
  1313.             lpcreg = (WORD_PTR)set_intercode(2);
  1314.             NEXT_INSTRUCTION;
  1315.          }
  1316. */
  1317.       }
  1318.    }
  1319.  
  1320.    for (i = 1; i <= op1; i++)
  1321.       *tempbreg-- = rreg[i];
  1322.  
  1323.    *tempbreg-- = (LONG)lereg;
  1324.    *tempbreg-- = (LONG)cpreg;
  1325.    *tempbreg-- = (LONG)trreg;
  1326.    *tempbreg-- = (LONG)hreg;
  1327.    *tempbreg-- = (LONG)breg;
  1328.    *tempbreg-- = op2;               /* next process' entry pt. */
  1329.    breg  = tempbreg;                /* next free space was b+6 */
  1330.    hbreg = hreg;
  1331.  
  1332.    NEXT_INSTRUCTION;    /* end of subtryme */
  1333.  
  1334. /*------------------------------------------------------------------*/
  1335. rerestore:
  1336.  
  1337.    tempbreg = breg + 3;
  1338.    hreg  = (LONG_PTR)*tempbreg;
  1339.    oldtr = (LONG_PTR)*(++tempbreg);
  1340.    while (trreg != oldtr) {
  1341.       top = (LONG_PTR)*(++trreg);
  1342.       *(LONG_PTR *)top = top;
  1343.    }
  1344.    cpreg  = (LONG_PTR)*(++tempbreg);
  1345.    lereg = (LONG_PTR)*(++tempbreg);
  1346.    for (i = op1; i >= 1; i--)
  1347.       rreg[i] = *(++tempbreg);
  1348.    NEXT_INSTRUCTION;    /* end of rerestore */
  1349.  
  1350. /*------------------------------------------------------------------*/
  1351. trrestore:
  1352.  
  1353.    tempbreg = breg + 3;
  1354.    hreg  = (LONG_PTR)*(tempbreg);
  1355.    oldtr = (LONG_PTR)*(++tempbreg);
  1356.    while (trreg != oldtr) {
  1357.       top = (LONG_PTR)*(++trreg);
  1358.       *(LONG_PTR *)top = top;
  1359.    }
  1360.    cpreg  = (LONG_PTR)*(++tempbreg);
  1361.    lereg = (LONG_PTR)*(++tempbreg);
  1362.    for (i = op1; i >= 1; i--)
  1363.       rreg[i] = *(++tempbreg);
  1364.  
  1365.    breg  = (LONG_PTR)*(breg + 2);
  1366.    hbreg = (LONG_PTR)*(breg + 3);
  1367.    NEXT_INSTRUCTION;    /* end of trrestore */
  1368.  
  1369. /*------------------------------------------------------------------*/
  1370. call_sub:                         /* (psc) */
  1371.  
  1372.    /* check for potential heap overflow */
  1373.    if (lereg < hreg + 100) {
  1374.       ereg = lereg;
  1375.       /* garbage_collection("call_sub"); */ /* GC buggy! */
  1376.       if (lereg < hreg + 100)     /* still too full */
  1377.      quit("Heap overflow\n");
  1378.    }
  1379.  
  1380.    if (interrupt_code > 0) {      /* combine with call_intercept check! */
  1381.       build_call(psc_ptr);
  1382.       lpcreg = (WORD_PTR)set_intercode(1);
  1383.       interrupt_code = 0;
  1384.       arm_intercept();
  1385.       psc_ptr = interrupt_psc;
  1386.    } else if (IS_PRED(psc_ptr) || IS_DYNA(psc_ptr)) {
  1387.       lpcreg = (WORD_PTR)GET_EP(psc_ptr);
  1388.    } else if (IS_BUFF(psc_ptr)) {
  1389.       lpcreg = (WORD_PTR)GET_NAME(psc_ptr) + 1;
  1390.    } else {
  1391.       build_call(psc_ptr);
  1392.       lpcreg = (WORD_PTR)set_intercode(0);
  1393.       psc_ptr = interrupt_psc;
  1394.    }
  1395.  
  1396.    if (call_intercept) {
  1397.       if (hitrace) {
  1398.          printf("call/exec: ");
  1399.          writepname(stdout, GET_NAME(psc_ptr), GET_LENGTH(psc_ptr));
  1400.          printf("/%d(", GET_ARITY(psc_ptr));
  1401.          for (i = 1; i <= GET_ARITY(psc_ptr); i++) {
  1402.             printterm(rreg[i], CAR);
  1403.             if (i < GET_ARITY(psc_ptr))
  1404.                printf(" ");
  1405.          }
  1406.          printf(")\n");
  1407.       }
  1408.       if (trace_sta) {
  1409.          if (hreg  > mheaptop ) mheaptop  = hreg;
  1410.          if (ereg  < mlocaltop) mlocaltop = ereg;
  1411.          if (breg  < mlocaltop) mlocaltop = breg;
  1412.          if (trreg < mtrailtop) mtrailtop = trreg;
  1413.       }
  1414.    }
  1415.  
  1416.    NEXT_INSTRUCTION;    /* end of call_sub */
  1417.  
  1418. }  /* end of main */
  1419.